COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(* $A+,D+*)
C00012 ENDMK
C⊗;
(* $A+,D+*)

program	PALINDROME(OUTPUT);

const	NUMMAX = 4; PALMAX = 100;  NUMLIM = 7; PALLIM = 101;
	TABMAX = 500;  TABLIM = 501;
var C, I, J, K, L, M, N, NXTOT, TABL, NMAX, NMIN, DCLASS,
	 NUMVAL, CVAL, CVAL2, PALTOT, PALVAL, CARRY : integer;
	CMIN, CMAX : integer; 
    NUM : array [1..NUMLIM] of integer;
    PAL, PAL2 : array [1..PALLIM] of integer;
    TAB : array [0..TABLIM] of integer;
    TEMP : array [1..5] of integer;

begin (* Main program*)
for I := 1 to NUMMAX do NUM[I] := 0;
NUM [2] := 1; NUMVAL := 2;		(* Initial conditions *)
writeln (OUTPUT,
	'  Palindrome formation tested to a maximum of',PALMAX:4,' digits');
writeln (OUTPUT);
while NUMVAL <= NUMMAX do
    begin (*while NUMVAL <= NUMMAX*)
    CVAL := NUMVAL div 2;
    CVAL2 := CVAL + NUMVAL mod 2;
    CMIN := 1;
    CMAX := 19;				(* gets reduced by 1 below*)
    if CVAL > 1 then for I := 2 TO CVAL do
	begin
	CMIN := CMIN * 19;
	CMAX := CMAX * 19;
	end;
    if (CVAL2 - CVAL) = 1 then
	begin
	CMIN := CMIN * 10;
	CMAX := CMAX * 10;
	end;
    CMAX :=  CMAX - 1;
	
    writeln (OUTPUT,'DATA FOR',NUMVAL:2,'-DIGIT DECIMAL NUMBERS');
    I := CMAX -CMIN + 1;
    writeln(OUTPUT,'   WHICH CAN BE GROUPED INTO',I:5,' CLASSES');
    writeln(OUTPUT);
    writeln(TTY);
    writeln (TTY,'DATA FOR',NUMVAL:2,'-DIGIT DECIMAL NUMBERS'); BREAK;
    DCLASS := NUMVAL;
    for I := 1 TO PALMAX do PAL[I] := 0;
    for I := 0 to TABMAX do TAB[I] := 0;    (* palindrome add data *)
    PALTOT := 0;                            (* Count of number of palindromes *)
    NXTOT := 0;                             (* Count of non-palindromes*)
    NMAX := 0;				    (* Maximum adds for a palindrome*)
    NMIN := 500;                            (* Minimun adds for intransigents *)
    M := 0;
    for C := CMIN to CMAX do
	begin				(* FOR C := CMIN TO CMAX*)
	I := C;
	J := CVAL;  L := CVAL2 + 1;
	if (CVAL2 - CVAL) = 1 then
	    begin
	    TEMP[CVAL2] := I mod 10;
	    NUM[CVAL2] := TEMP[CVAL2];
	    I := I div 10;
	    end;
	for K := CVAL downto 1 do
	    begin
	    TEMP[K] := I mod 19;
	    if TEMP[K] < 10 then
		begin
		if K = 1 then
		    begin
		    NUM[L] := TEMP[K] -1;
		    NUM[J] := 1;
		    end
		else 
		    begin
		    NUM[L] := TEMP[K];
		    NUM[J] := 0;
		    end;
		end
	    else
		begin
		NUM[L] := 9;
		NUM[J] := TEMP[K] - 9;
		end;
	    J := J - 1;
	    L := L + 1;
	    I := I div 19;
	    end;
(*	for I := 1 to NUMVAL  do write(TTY,NUM[I]:1); write(TTY,'  '); *)
	N := 0;                         (* To count number of additions *)
	for I := 1 to NUMVAL do PAL[I] := NUM[I];
	for I := NUMVAL + 1 TO PALMAX do PAL[I] := 0;
	PALVAL := NUMVAL;
	while PALVAL <= PALMAX do
	    begin                                   (* while PALVAL <= PALMAX*)
	    I := 1; J := PALVAL;
	    while ((PAL[I] = PAL [J]) and (I < J)) do
		begin
		I := I + 1;  J := J - 1;
		end;
	    if I >= J then
		begin
		TAB[N] := TAB[N] + 1;		(*Add to table of depths*)
		if N > NMAX then NMAX := N;
		PALTOT := PALTOT + 1;
		PALVAL := PALMAX + 1;
		end
	    else                                   (* Still not a palindrome*)
		begin                               (* try another add*)
		J := PALVAL; CARRY := 0;
		for I := 1 to PALVAL do
		    begin                           (* Add numbers*)
		    PAL2[I] := PAL[I] + PAL[J] + CARRY;
		    if PAL2[I] > 9 then
			begin
			PAL2[I] := PAL2[I] - 10;  CARRY := 1;
			end
		    else CARRY := 0;
		    J := J - 1;
		    end;                            (* add numbers*)
		if CARRY = 1 then
		    begin
		    PALVAL := PALVAL +1; PAL2[PALVAL] := 1;
		    end;
		N := N + 1;
		if PALVAL = PALMAX + 1  then        (* Limit on depth*)
		    begin                           (* One to report*)
		    if N < NMIN then NMIN := N;
		    NXTOT := NXTOT + 1;  
		    if NXTOT = 1 then
			begin
			writeln(OUTPUT,
    'INTRANSIGENT CLASSES DEFINED BY REVERSED DIGIT ADDITIONS, WITHOUT CARRIES');
			writeln(OUTPUT,
    '	* MEANS,- ONE NUMBER IN THIS CLASS IS AN INITIAL PALINDROME');
			writeln(OUTPUT);
			for J := 1 TO 3 do
			    begin
			    write(OUTPUT,'   ');
			    for I := 1 to CVAL do write (OUTPUT,' SUM',I:1);
			    if (CVAL2 - CVAL) = 1 then  write (OUTPUT,' MID#');
			    write(OUTPUT,'  ');
			    end;
			writeln (OUTPUT);
			M := 0;
			end;
		    write(OUTPUT,'   ');
		    write(TTY,'  ');
		    for J := 1 to CVAL2 do
			begin
			write (OUTPUT,TEMP[J]:5);
			write (TTY,TEMP[J]:3);
			end;
		    J := 1;
		    while ((J <= CVAL) and ((TEMP[J] mod 2) = 0)) do J := J + 1;
		    if J > CVAL then write(OUTPUT,' *') else write(OUTPUT,'  ');
		    M := M + 1;
		    if (M mod 3) = 0 then writeln(OUTPUT);
		    end                     (* of one to report*)
		else for I := 1 to PALVAL do PAL[I] := PAL2[I];
		end;
	    end                      (* while PALVAL <= PALMAX*);
	end;				(* FOR C := CMIN TO CMAX*)
    if NXTOT = 0 then writeln (OUTPUT,'         No intransigent numbers found');
    writeln (OUTPUT);
    writeln(OUTPUT);
    writeln (OUTPUT,NMAX:6,' MAX ADDS for',PALTOT:7,' PALINDROME CLASSES, with',
	    NXTOT:6,' INTRANSIGENT CLASSES');
    if NXTOT = 0 then writeln (OUTPUT,'           No intransigent numbers found') ;
    writeln(OUTPUT);
    writeln(OUTPUT,'palindromes grouped as to their add depths');
    writeln(OUTPUT,
	'    0-ADD GROUP ALSO INCLUDES INDIVIDUAL PALINDROMES INDICATED BY * ABOVE');
    writeln(OUTPUT);
    writeln(OUTPUT,
        '      ADDS  CLASSES   ADDS  CLASSES   ADDS  CLASSES   ADDS  CLASSES');
    M := 0;
    for I := 0 to NMAX do
	begin
	if TAB[I] <> 0 then
	    begin
	    write(OUTPUT,I:10,TAB[I]:6);
	    M := M + 1;
	    if (M mod 4) = 0 then writeln(OUTPUT);
	    end;
	end;
    writeln(OUTPUT);
    writeln(OUTPUT);
    NUMVAL := NUMVAL + 1;
    end (*while NUMVAL <= NUMMAX*);
end.